program PXLTYP;

(*
	Type out a PXL file.
	(c) 1981 by David Fuchs
*)

LABEL	9; (* go here to abort *)

CONST
	copyright=' Copyright (C) 1981 by David Fuchs. ';

	PXLID=1001;	(* this pgm works for this version of PXL *)
	MAXPXL=80000;	(* max no of words in pxl file we can read *)
        FIXPERPT=1048576;       (* FIX's per point -- 1pt=2↑20fix *)

TYPE
        (* here we disect words into bytes *)
 /* DEC */
        eightbit=0..255;
        sixteenbit=0..65535;
        thirtytwobit=0..4294967294;
        oneoffour=1..4;
        hack=packed record
                case oneoffour of
                1:(     xword: integer);
		2:(	word: thirtytwobit;
			junkc:0..15);
                3:(     leftsixteen:sixteenbit;
                        rightsixteen:sixteenbit;
                        junka:0..15);
                4:(     byte0:eightbit;
                        byte1:eightbit;
                        byte2:eightbit;
                        byte3:eightbit;
                        junkb:0..15);
                end;
 /* ENDDEC */

 /* IBM
        eightbit=packed 0..255;
        sixteenbit=packed 0..65535;
        oneofthree=packed 1..3;
        hack=packed record
                case oneofthree of
                1:(     word: integer);
                2:(     leftsixteen:sixteenbit;
                        rightsixteen:sixteenbit);
                3:(     byte0:eightbit;
                        byte1:eightbit;
                        byte2:eightbit;
                        byte3:eightbit);
                end;
    ENDIBM */

VAR

 /* DEC */
terout, typfil: packed file of char;
i,j,k:integer; fnam:packed array[1..99] of char; (* for file name hack *)
 /* ENDDEC */
 /* IBM
terout, typfil: text;
    ENDIBM */

pxlfil:	file of integer;

pxl:	array[0..MAXPXL] of hack; (* image of PXL file *)
pxllen:	integer;	(* number of words in PXL file *)
directoryptr: integer;	(* second-to-last word in pxl file *)
designsize: real;	(* from third-to-last word *)
magnification: integer;	(* fourth-to-last *)
checksum: integer;	(* fifth-to-last *)
ch:	integer;

(* utility routines *)


(* returns the 'printing length' of an integer *)

function plen(i:integer):integer;
        var ans: integer;
        begin
        if i<0 then begin i:=0-i; ans:=1; end
        else ans:=0;
        repeat
                i:=i div 10;
                ans:=ans+1;
        until i=0;
        plen:=ans;
        end;

procedure jfns(var s:string; var chan:file; bits:integer); extern;
(* puts name of file open on chan into s. Format depends on bits, ala tops20 JFNS *)

procedure error(err,parm:integer);
        CONST MAXE=7; (* error numbers are in the range 1..MAXE *)
        var fatal:boolean; cont,knt:integer;
        begin

        writeln(terout);

        if err>0 then fatal:=false
        else begin
                fatal:=true;
                err:=-err;
                write(terout,'FATAL ');
                end;

        writeln(terout,'PXLTYP error (number ',err:plen(err),')');

        if (0<err) and (err<=MAXE) then case err of
        1: writeln(terout,'PXL file too long; I can only handle ',
                                        parm:plen(parm),'words.');
        2: writeln(terout,'Low order 4 bits of word ',
		parm:plen(parm),' not 0.');
        3: writeln(terout,'Word 0=',parm:plen(parm),', which is not PXLID.');
        4: writeln(terout,'Last Word=',parm:plen(parm),
		', which is not PXLID.');
        5: writeln(terout,'Directory Pointer =  ',parm:plen(parm),
		', which isn''t consistent with the length of the PXL file.');
        6: writeln(terout,'Raster Pointer for character ',parm:plen(parm),
		' out of range.');
        7: writeln(terout,'Raster Pointer for character ',parm:plen(parm),
		' out of range, considering this char''s raster size.');
        end (* of case *)
        else begin
                writeln(terout,'Bad error number in PXLTYP! ',err:plen(err));
                fatal:=true;
                end;

        if fatal then begin
		writeln(terout,'Fatal error.');
                goto 9;
                end;
        end;


function unfix(f:integer):real;
        var h:hack; i:integer;
        begin
        h.word:=f;
        if h.leftsixteen<32768 then i:= h.leftsixteen*65536+h.rightsixteen
        else i:=(h.leftsixteen-65535)*65536+(h.rightsixteen-65536);
        unfix:=i/fixperpt; (* converts a FIX integer to a real number of pts *)
        end;

(* write out an integer the right way *)
procedure writeint(int:integer);
        procedure wint(int:integer);
                begin
                if int>0 then begin
                        wint(int div 10);
                        write(typfil,(int mod 10):1);
                        end;
                end;
        begin
        if int=0 then write(typfil,'0')
        else begin
                if int<0 then begin write(typfil,'-'); int:=0-int; end;
                wint(int);
                end;
        end;

(* write out an octal number, almost the right way *)
procedure writeoct(oct:integer);
        var i:integer;
        procedure woct(oct:integer);
                begin
                if oct>0 then begin
                        woct(oct div 8);
                        write(typfil,(oct mod 8):1);
                        end;
                end;
        begin
        write(typfil,'''');
        if oct=0 then write(typfil,'0')
        else begin
                if oct<0 then begin
                        write(typfil,'-');
                        oct:=-oct; (* small bug here, if oct=-MAXINT *)
                        end;
                woct(oct);
                end;
        end;

(* write out a real number in a reasonable fashion *)
procedure writereal(r:real;dp:integer);
        var i:integer;
        begin
        if r<0 then begin r:=0.0-r; write(typfil,'-'); end;
        if r=0.0 then begin
                write(typfil,'0.');
                for i:=1 to dp do write(typfil,'0');
                end
        else begin
                (* do integer part *)
                i:=trunc(r);
                writeint(i);
                (* do fractional part *)
                r:=r-i;
                write(typfil,'.');
                for i:=1 to dp do begin
                        r:=r*10;
                        write(typfil,trunc(r):1);
                        r:=r-trunc(r);
                        end;
                end;
        end;

procedure writepix(pix,bits: integer);
	var bit,i:integer;
	begin
	bit:=32768;
	for i:=1 to bits do begin
		if odd(pix div bit) then write(typfil,'X')
		else write(typfil,'.');
		bit:=bit div 2;
		end;
	end;

procedure readinpxlfile;
	begin
	pxllen:=0;
	while (pxllen<MAXPXL) and (not eof(pxlfil)) do begin
 /* DEC */
                pxl[pxllen].xword:=pxlfil↑;
 /* ENDDEC */
 /* IBM
                pxl[pxllen].word:=pxlfil@;
    ENDIBM */
		get(pxlfil);
		pxllen:=pxllen+1;
		end;
	if not eof(pxlfil) then error(1,pxllen);
	end;

procedure checkpxlformat;
	var words,i:integer;
	begin
 /* DEC */
	for i:=0 to pxllen-1 do if pxl[i].junka<>0 then error(2,i);
 /* ENDDEC */
	if pxl[0].word<>PXLID then error(3,pxl[0].word);
	if pxl[pxllen-1].word<>PXLID then error(4,pxl[pxllen-1].word);
	directoryptr:=pxl[pxllen-2].word;
	if directoryptr<>pxllen-517 then error(5,directoryptr);
	designsize:=unfix(pxl[pxllen-3].word);
	write(typfil,'Design size ');
		writereal(designsize,4); writeln(typfil,' pt.');
	magnification:=pxl[pxllen-4].word;
	write(typfil,'Magnification ');
		writereal(magnification,0); writeln(typfil);
	checksum:=pxl[pxllen-5].word;
	write(typfil,'Checksum '); writeoct(checksum); writeln(typfil);
	for i:=0 to 127 do begin
		if pxl[directoryptr+i*4+2].word >= directoryptr
			then error(6,i);
		words:=((pxl[directoryptr+i*4].leftsixteen+31) div 32)
		      * (pxl[directoryptr+i*4].rightsixteen);
		if pxl[directoryptr+i*4+2].word + words > directoryptr
			then error(7,i);
		end;
 (* doesn't check overlapping of chars' pixels *)
	end;

procedure printpxlch(ch:integer);
	var dptr,rptr,ph,pw,offset,tpw,i:integer; width:real;
	begin
	writeln(typfil);
	write(typfil,'Char '); writeoct(ch); writeln(typfil);
	dptr:=directoryptr+ch*4;
	pw:=pxl[dptr].leftsixteen;
	write(typfil,'Pixel Width '); writeint(pw);
	ph:=pxl[dptr].rightsixteen;
	write(typfil,' Pixel Height '); writeint(ph); writeln(typfil);
	write(typfil,'X-offset '); 
	offset:=pxl[dptr+1].leftsixteen;
	if offset>32767 then offset:=offset-65536;
	writeint(offset);
	write(typfil,' Y-offset '); 
	offset:=pxl[dptr+1].rightsixteen;
	if offset>32767 then offset:=offset-65536;
	writeint(offset);
	writeln(typfil);
	rptr:=pxl[dptr+2].word;
	write(typfil,'Raster Pointer '); writeint(rptr); writeln(typfil);
	width:=unfix(pxl[dptr+3].word);
	write(typfil,'Width '); writereal(width,5); write(typfil,' (');
		writereal(width*designsize,4); writeln(typfil,' pt.)');
	for i:=1 to ph do begin
		tpw:=pw;
		while tpw>31 do begin
			writepix(pxl[rptr].leftsixteen,16);
			writepix(pxl[rptr].rightsixteen,16);
			tpw:=tpw-32;
			rptr:=rptr+1;
			end;
		if tpw>0 then begin
			if tpw>15 then begin
				writepix(pxl[rptr].leftsixteen,16);
				if tpw>16 then
				  writepix(pxl[rptr].rightsixteen,tpw-16);
				end
			else if tpw>0 then writepix(pxl[rptr].leftsixteen,tpw);
			rptr:=rptr+1;
			end;
		writeln(typfil);
 (* bug-should check righthand pixels for emptyness (>pw) *)
		end;
	end;

procedure doit;
	begin
	readinpxlfile;
	checkpxlformat;
	for ch:=0 to 127 do begin write(terout,ch:4); printpxlch(ch); end;
	end;

(* And here we go...main program *)
begin

 /* DEC */
rewrite(terout,'TTY:');
writeln(terout,copyright);
write(tty,'PXL file(s): '); reset(pxlfil,'':@); writeln(tty);
	jfns(fnam,pxlfil,001000000000B);
	i:=1; while ord(fnam[i])>0 do i:=i+1;
	j:=i;
	fnam[j]:='.'; j:=j+1;
	fnam[j]:='T'; j:=j+1;
	fnam[j]:='Y'; j:=j+1;
	fnam[j]:='P'; j:=j+1;
	fnam[j]:=chr(0);
	write(tty,'Writing ');
	for k:=1 to j do write(tty,fnam[k]);
	writeln(tty);
	rewrite(typfil,fnam);
	for k:=1 to i-1 do write(typfil,fnam[k]);
	writeln(typfil);
	doit;

 /* ENDDEC */
 /* IBM
rewrite(terout);
writeln(terout,copyright);
reset(pxlfil,'DDNAME=PXL');
rewrite(typfil,'DDNAME=TYP');
doit;
    ENDIBM */

9:
end.